HPAVC/HPAVC CD-ROM.iso/pc/UNHQX.ZIP/unhqx.pas

Pascal/Delphi Source File | 1995-03-07 | 9.4 KB | 392 lines

(* UNHQX.PAS, Turbo Pascal 7.0 object-unit to decode Mac BinHex files     *)
(* ---------------------------------------------------------------------- *)
(* by Robert Rothenburg Walking-Owl, <[e-mail]>          *)
(* -- CopyLeft 1994 - Feel free to use and modify as needed, but please   *)
(*                    only distribute unmodified source code. If you make *)
(*                    any improvements, please let me know.               *)


unit UnHQX;

(* Inline code has been used for improved speed and smaller size, though  *)
(* the 'original' Pascal code is included in comments to facilitate port- *)
(* ing to other systems or flavors of Pascal.                             *)


interface

    (* Buffer size is somewhat arbitrary.  Larger buffer sizes should  *)
    (* decode faster. A better method would be to check available mem- *)
    (* ory and allocate an appropriate sized-buffer...                 *)

type
     TBuff = array [1..4096] of byte;
     pBuff = ^TBuff;

  HQX = object
         private
          fif: ^file;
          LastChar: Char;
          RLE: Byte;
          DBuffSz,
          DBuffPtr:  Word;
          DiskBuffer,
          Bit_Buffer: pBuff;
          procedure UpDateCRC(c: Word); virtual;
          procedure PutBits(b: Word); virtual;
          function ReadChar: Char; virtual;
          procedure Fetch; virtual;
          function Retrieve: Char; virtual;
          function Decode(C: Char): Byte; virtual;
         public
          CRC,
          Origin,
          FilePtr: LongInt;
          Cur,
          Ptr: Word;
          Loc: Byte;
          Header: record
                    FName: string[63];
                    Version:  Byte;
                    FType,
                    Author: array[1..4] of char;
                    FileCRC,
                    CRC,
                    Flags:  Word;
                    DataLen,
                    RsrcLen: LongInt;
                  end;
          constructor Init(var f: file; Orig: LongInt);
          function fCRC: Word;
          function fGetC: Char; virtual;
          procedure fGetBlock(var Block; Size: word); virtual;
          function fGetW: Word; virtual;
          function fGetL: LongInt; virtual;
          procedure fSeek(Position: LongInt); virtual;
          procedure fSkip(Position: LongInt); virtual;
         { procedure fRewind(Position: LongInt); virtual; }
          destructor Done;
        end;

implementation

const
 (* Bit_Sizes[x] = 1 ShL (x-1) *)
 {  Bit_Sizes: array [1..8] of byte = (  1, 2, 4, 8, 16, 32, 64, 128); }

  NUL = #00;
  TAB = #09;
  LF  = #10;
  FF  = #12;
  CR  = #13;
  SP  = #32;

  RLEMARKER = #144; (* 0x90 = RLE marker *)

  cTBuffSz = SizeOf(TBuff);


function SwapLong(x: LongInt): LongInt; assembler;
asm
    MOV AX, [BP+6]
    MOV DX, [BP+8]
    XCHG AX, DX
    XCHG AL, AH
    XCHG DL, DH
end;

procedure HQX.UpDateCRC(c: Word);
var
  i: Byte;
  Temp: word;
begin
  Temp := CRC;
  asm
                MOV CX, $0808
  @BitLoop:     SHL c, 1
                TEST Temp, $8000
                JZ @SkipConst
                SHL Temp, 1
                AND Temp, $FFFF
                XOR Temp, $1021
                JMP @SkipShift
  @SkipConst:   SHL Temp, 1
  @SkipShift:   MOV AX, c
                SHR AX, CL
                XOR Temp, AX
                AND c, $00FF
                DEC CH
                OR CH, CH
                JNZ @BitLoop
  end;
 (* --- Pascal code to do the same as the above inline code --- *)
 { for i:= 0 to 7 do begin
      c := c ShL 1;
      if (Temp and $8000)<>0
        then Temp := ((Temp ShL 1) and $FFFF) xor  $1021
        else Temp := Temp ShL 1;
      Temp := Temp xor (c ShR 8);
      c := c and $FF;
    end; }
  CRC := Temp;
end;

function HQX.fCRC: Word;
begin
  UpDateCRC(0);
  UpDateCRC(0);
  fCRC := CRC;
end;

procedure HQX.PutBits (b: Word);
var
    Num: Byte;
    PPtr: Word;
    Hold: pointer;
begin
  Hold := Bit_Buffer;
  Num  := Loc;
  PPtr := Ptr;
  asm
               PUSH DS
               LDS SI, Hold
               MOV BX, PPtr
               MOV AL, Num
               MOV CX, $20           { num := 6 (Bit_Sizes[6] = 32;) }
    @BitCycle: CMP AL, 0             { is Loc=0?                     }
               JNE @NormLoc
               MOV AL, $80           { Loc := $80                    }
               INC BX                { inc (Ptr);                    }
               CMP BX, cTBuffSz      { is Ptr > SizeOf(TBuff)?       }
               JNA @PtrOk
               MOV BX, 1
    @PtrOk:    MOV Byte Ptr DS:[SI+BX-1], 0
    @NormLoc:  TEST CX, b
               JZ  @Continue
               OR  Byte Ptr DS:[SI+BX-1], AL
    @Continue: SHR AL, 1
               SHR CL, 1
               CMP CL, 0
               JA @BitCycle
               MOV PPtr, BX
               MOV Num, AL
               POP DS
  end;
  Ptr := PPtr;
  Loc := Num;

 (* --- Pascal code to do the same as the above inline code --- *)
  {
  num := 6;
  repeat
   if Loc = 0
    then begin
      Loc := $80;
      inc (Ptr);
      if Ptr>SizeOf(TBuff) then Ptr := 1;
      Bit_Buffer^[Ptr] := 0;
     end;
   if ( (b and Bit_Sizes [num] ) <> 0)
     then Bit_Buffer^ [Ptr] := Bit_Buffer^ [Ptr] or Loc;
   Loc := Loc ShR 1;
   dec (num)
  until num = 0;
  }
end;

function HQX.Decode(C: char): Byte;
const
  Table: string[64] =
   '!"#$%&''()*+,-012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr';
var d: Byte;
begin

 (* --- Pascal code to do the same as the above inline code --- *)
 { d := Pos(C,Table);
  if d=0
    then Decode := $FF
    else Decode := Pred(d); }
  asm
                MOV SI, Offset Table+1
                XOR BX, BX
                MOV AL, C
  @LookUpLoop:  CMP AL, [SI+BX]
                JE  @FoundMatch
                INC BX
                CMP BL, 64
                JL  @LookUpLoop
                MOV BL, $FF
  @FoundMatch:  MOV @Result, BL
  end;
end;

function HQX.ReadChar: Char;
begin
  if DBuffPtr > DBuffSz
    then begin
      BlockRead(fif^,DiskBuffer^,SizeOf(TBuff),DBuffSz);
      DBuffPtr := 1
     end;
  ReadChar := Chr(DiskBuffer^[DBuffPtr]);
  inc(DBuffPtr);
end;

procedure HQX.Fetch;
var C: char;
    i: Word;
    j: Byte;
begin
   i := 4; (* 4 encoded chars <-> 3 raw chars *)
           (* No. chars fethced related to buffer size... *)
   repeat
     C := ReadChar;
     if (C<>CR) and (C<>LF) and (C<>TAB) and (C<>FF) and (C<>SP)
      then if C = ':'
       then begin
         PutBits(0);
         i := 1 (* Set an EoF flag needed! *)
        end
       else begin
         j := Decode(C);
         PutBits(j)
        end;
     dec(i);
   until (i=0) or (DBuffSz=0);
end;

function HQX.Retrieve: Char;
begin
  Retrieve := Chr(Bit_Buffer^[Cur]);
  inc(Cur);
  if Cur>SizeOf(TBuff)
    then Cur := 1;
end;

function HQX.fGetC: Char;
var C,R: Char;
begin
  if RLE<>0
    then begin
        R := LastChar;
        dec(RLE);
      end
    else begin
      if (Cur+1)>=Ptr { Cur+3 }
        then Fetch;
      C := Retrieve;
      if C<>RLEMARKER
        then begin
          R := C;
          LastChar := C
          end
        else begin
            C := Retrieve;
            if C=NUL
              then begin
                  R := RLEMARKER;
                  LastChar := RLEMARKER;
                end
              else begin
                R := LastChar;
                RLE := ord(C)-2
               end
          end;
     end;
  UpdateCRC(Ord(R));
  fGetC := R;
  inc(FilePtr);
end;

procedure HQX.fGetBlock(var Block; Size: word);
var Buffer: TBuff absolute Block;
    i: word;
begin
  if Size<>0 (* Size cannot be more than SizeOf(TBuff) ! *)
    then for i := 1 to Size do Buffer[i] := ord(fGetC);
end;

function HQX.fGetW: Word;
var i: word;
begin
  fGetBlock(i,2);
  fGetW := Swap(i); (* Automatically convert endianess *)
end;

function HQX.fGetL: LongInt;
var i: LongInt;
begin
  fGetBlock(i,4);
  fGetL := SwapLong(i)
end;

procedure HQX.fSeek(Position: LongInt);
var C: char;
begin
  if FilePtr<Position (* Otherwise error?! *)
    then repeat
       C := fGetC;
       until FilePtr=Position;
end;

procedure HQX.fSkip(Position: LongInt);
begin
  if Position>0
    then fSeek(FilePtr+Position)
end;

(* Bug: Routine seems to get caught in an infinite loop ... *)
{
procedure HQX.fRewind(Position: LongInt);
begin
  if (RLE=0) and (Position<(SizeOf(TBuff)-8)) (* arbitrary *)
    then repeat
        dec(Cur);
        if Cur=0
          then Cur := SizeOf(TBuff);
        dec(Position);
      until Position=0;
end;
}
constructor HQX.Init(var f: file; Orig: LongInt);
var Temp : Word;
begin
  RLE := 0;
  LastChar := NUL;
  Loc := $80;
  Ptr := 1;
  Cur := 1;
  GetMem(Bit_Buffer,SizeOf(TBuff)); { Doesn't check MemAvail! }
  GetMem(DiskBuffer,SizeOf(TBuff));
  DBuffSz  := 0;
  DBuffPtr := 1;
  FillChar(Bit_Buffer^,SizeOf(TBuff),NUL);
  FilePtr := 0;
  CRC     := $0000;
  fif := @f;
  Seek(fif^,Orig);
  (* Assumes Orig points to position in file relative to the *)
  (* "(This file ..." header in most BinHex files            *)
  repeat until (ReadChar=':');
  (* Read header information ...                             *)
  FillChar(Header,SizeOf(Header),NUL);
  Header.FName[0] := fGetC;
  fGetBlock(Header.FName[1],Length(Header.FName));
  Header.Version  := Ord(fGetC);
  fGetBlock(Header.FType,4);
  fGetBlock(Header.Author,4);
  Header.Flags := fGetW;
  Header.DataLen := fGetL;
  Header.RsrcLen := fGetL;
  Header.FileCRC := fCRC;
  Header.CRC := fGetW; (* What is the CRC algorithm? ... *)

end;

destructor HQX.Done;
begin
  FreeMem(Bit_Buffer,SizeOf(TBuff));
  FreeMem(DiskBuffer,SizeOf(TBuff));
end;

end.